home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / comp / assembler / vaxmini.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  12.9 KB  |  287 lines
  1. (herald (assembler mini t 0)
  2.         (env t (assembler as_open) (assembler mark) (assembler ib)))
  3.  
  4. ;;; Copyright (c) 1985 Yale University
  5. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  6. ;;; This material was developed by the T Project at the Yale University Computer 
  7. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  8. ;;; and to use it for any purpose is granted, subject to the following restric-
  9. ;;; tions and understandings.
  10. ;;; 1. Any copy made of this software must include this copyright notice in full.
  11. ;;; 2. Users of this software agree to make their best efforts (a) to return
  12. ;;;    to the T Project at Yale any improvements or extensions that they make,
  13. ;;;    so that these may be included in future releases; and (b) to inform
  14. ;;;    the T Project of noteworthy uses of this software.
  15. ;;; 3. All materials developed as a consequence of the use of this software
  16. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  17. ;;;    of acknowledging credit in academic research.
  18. ;;; 4. Yale has made no warrantee or representation that the operation of
  19. ;;;    this software will be error-free, and Yale is under no obligation to
  20. ;;;    provide any services, by way of maintenance, update, or otherwise.
  21. ;;; 5. In conjunction with products arising from the use of this material,
  22. ;;;    there shall be no use of the name of the Yale University nor of any
  23. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  24. ;;;    without prior written consent from Yale in each case.
  25. ;;;
  26.  
  27. ;;; Implements Szymanski's algorithm for span dependent instruction 
  28. ;;; computation.  April 1978, CACM, pp300-308.
  29.  
  30. (define (minimize-displacements sdfs)
  31.     (receive (first last) (initialize-sdfs sdfs)
  32.       (compute-sdf-widths sdfs first last)))
  33.  
  34. (define (fixup-labels ibv sdfs m-addrs m-sdf-numbers)
  35.     (let ((adjs (compute-adjustments sdfs)))
  36.       (fixup-ibs ibv adjs sdfs)
  37.       (adjust-adjustments-for-alignments adjs sdfs)
  38.       (fixup-marks m-addrs m-sdf-numbers adjs) 
  39.                                                    
  40.       ;; womp final width and displacement into the fg
  41.       (walk-vector (lambda (sdf) 
  42.                      (cond ((not (empty? (sdf-span sdf)))
  43.                             (set (vref (sdf-vars sdf) (car (sdf-indices sdf)))
  44.                                  (sdf-width sdf))
  45.                             (set (vref (sdf-vars sdf) (cdr (sdf-indices sdf)))
  46.                                  (sdf-span sdf)))))
  47.                    sdfs)
  48.  
  49.       ;; return maximum adjustment (amount of increase in output size)
  50.       (let ((last-adj-i (fx- (vector-length adjs) 1)))
  51.          (if (fx< last-adj-i 0) 
  52.              0 
  53.              (vref adjs last-adj-i)))
  54.       ))
  55.  
  56. ;;; The data structures have been set up by 'count' and 'mark'
  57.  
  58. ;;; Initialize sdf structures:
  59. ;;;  - set 'next-dirty' slot of prev sdf to this sdf
  60. ;;;  - compute initial spans
  61. ;;;  - return the first and last dirty sdfs.
  62.  
  63. (define (initialize-sdfs sdfs)
  64.   (let ((sdfs-length (vector-length sdfs))
  65.         (first nil))
  66.     (iterate loop ((i 0) (prev nil))
  67.         (cond ((fx>= i sdfs-length) (return first prev))
  68.               (else
  69.                (let ((sdf (vref sdfs i)))
  70.                  (cond ((empty? (sdf-span sdf))   ; an alignment sdf
  71.                         (loop (fx+ i 1)  prev))
  72.                        (else                                     
  73.                         (initialize-span sdfs i sdf)
  74.                         (cond (prev (set (sdf-next-dirty prev) sdf))
  75.                               (else (set first sdf)))
  76.                         (loop (fx+ i 1) sdf)))))))))
  77.        
  78. ;;; Initialize a single sdf.  For a given sdf, add it to the crossers
  79. ;;; list of all sdfs that it crosses.
  80.  
  81. (define (initialize-span sdfs index sdf)
  82.    (set (sdf-span sdf)
  83.         (fx- (ib-address (sdf-label sdf)) 
  84.              (vref *mark-addresses* (sdf-mark sdf))))
  85.    (let ((dest (ib-sdf-number (sdf-label sdf))))
  86.       (receive (start end) 
  87.                (cond ((fx> dest index) (return (fx+ index 1) dest)) ;forward
  88.                      (else (return dest index)))
  89.          (do ((i start (fx+ i 1)))
  90.              ((fx>= i end) sdf)
  91.            (push (sdf-crossers (vref sdfs i)) sdf))))
  92.    (set (sdf-width sdf) (sdf-first-width sdf)))
  93.  
  94. ;;; Main loop for computing widths.
  95. ;;; Take next sdf off list of (possibly) dirty sdfs.  If the width
  96. ;;; of the sdf is big enough to hold its current value, mark it clean;
  97. ;;; otherwise, change the width, mark sdfs that cross this one dirty,
  98. ;;; and then mark this one clean.
  99.  
  100. (define (compute-sdf-widths sdfs next last)
  101.    (iterate loop ((next next) (last last) (clean-i 0) (dirty-i 0))
  102.       (cond ((null? next) (cons clean-i dirty-i))   ; only informational
  103.             (else
  104.              (let* ((sdf next)
  105.                     (cur-w (sdf-width sdf)))
  106.                (receive (new-w maybe-new-span)
  107.                         ((sdf-selector sdf) cur-w (sdf-span sdf))
  108.                  ;; width changed?
  109.                  (cond ((fx> new-w cur-w) 
  110.                         (set (sdf-width sdf) new-w)
  111.                         ;; if width didn't change, span shouldn't change.
  112.                         (set (sdf-span sdf) maybe-new-span)
  113.                         (let ((new-last (dirty-crossers sdf (fx- new-w cur-w) last)))
  114.                            (loop (swap (sdf-next-dirty next) 0) 
  115.                                  new-last
  116.                                  (fx+ dirty-i 1)
  117.                                  clean-i)))
  118.                        (else
  119.                         (loop (swap (sdf-next-dirty next) 0) 
  120.                               last 
  121.                               dirty-i
  122.                               (fx+ clean-i 1))))
  123.                  )))))) 
  124.                  
  125. ;;; Utility for adjusting spans in all sdfs that span an sdf that has changed.
  126.  
  127. (define (dirty-crossers sdf delta current-last)
  128.   ;; list affected sdf's as dirty
  129.   (iterate set-dirty ((dirts (sdf-crossers sdf))
  130.                       (new-last current-last))
  131.      (cond ((null? dirts) new-last)
  132.            (else
  133.             (modify (sdf-span (car dirts))
  134.                     (lambda (s) (cond ((fx< s 0) (fx- s delta))
  135.                                       ((fx> s 0) (fx+ s delta))
  136.                                       (else (error "zero span 1")))))
  137.             (cond ;; was clean?
  138.                   ((eq? 0 (sdf-next-dirty (car dirts))) 
  139.                    (set (sdf-next-dirty new-last) (car dirts))
  140.                    (set (sdf-next-dirty (car dirts)) nil)
  141.                    (set-dirty (cdr dirts) (car dirts)))
  142.                   ;; already dirty
  143.                  (else  
  144.                   (set-dirty (cdr dirts) new-last)))))))
  145.                                   
  146. ;;; Alignment adjustments happen at the end, and are not subjected
  147. ;;; to minimization.
  148.  
  149. (define (adjust-align-crossers sdf delta)
  150.   (let ((xers (sdf-crossers sdf)))
  151.     (if (not (empty? (sdf-span sdf))) (error "non-alignment sdf"))
  152.     (do ((xers xers (cdr xers)))
  153.         ((null? xers) nil)
  154.       (modify (sdf-span (car xers))
  155.          (lambda (s) 
  156.              (cond ((fx< s 0) (fx- s delta))
  157.                    ((fx> s 0) (fx+ s delta))
  158.                    (else (error "zero span 2"))))))))
  159.  
  160. ;;; After the sdf withs have been computed, we have to go back and adjust all 
  161. ;;; the label (and mark) address. Some addresses will have to be adjusted for 
  162. ;;; alignment. 'mark' inserted the maximum possible fill for alignment,
  163. ;;; and now we remove whatever is necessary.  Spans of sdf's that cross the
  164. ;;; alignments must be adjusted.
  165.                                                                  
  166. ;;; Compute adjustments table: eg, a label is preceded by 6 sdfs, so the 6th 
  167. ;;; element of this table will give the amount to adjust the label by.
  168. ;;; This leaves the 0th slot as a dummy (this is a feature).
  169.  
  170. (define (compute-adjustments sdfs)
  171.   (let* ((sdfs-length (vector-length sdfs))
  172.          (adj-length (fx+ sdfs-length 1))
  173.          (adjustments (make-vector adj-length)))
  174.     (set (vref adjustments 0) 0)
  175.     (iterate loop ((i 0) (accum-adjustment 0))
  176.       (cond ((fx>= i sdfs-length) adjustments)
  177.             (else
  178.               (let ((sdf (vref sdfs i)))             
  179.                 (cond ;; align sdfs don't count
  180.                       ((empty? (sdf-span sdf))
  181.                        (set (vref adjustments (fx+ i 1)) accum-adjustment)
  182.                        (loop (fx+ i 1) accum-adjustment))
  183.                       (else
  184.                        (let ((adj (fx+ accum-adjustment
  185.                                        (fx- (sdf-width sdf)
  186.                                             (sdf-first-width sdf)))))
  187.                          (set (vref adjustments (fx+ i 1)) adj)
  188.                          (loop (fx+ i 1) adj))))))))))
  189.  
  190. ;;; Apply the adjustments to the labels (IBs).  Align each
  191. ;;; after adjustment, and accumulate the adjustments made for alignment.
  192.  
  193. ;; Hacko alignment stuff.
  194.  
  195.   ;;; M is one less than multiple being align to.  The multiple must be
  196.   ;;; a power of 2.  So, to do quadword alignment, M is 7
  197.  
  198.   ;;; Except that we do everything in terms of bits, not bytes, so M is 63
  199.  
  200.   (define-integrable (as-align lc m)
  201.     (fixnum-logand (fx+ lc m) (fixnum-lognot m)))
  202.  
  203.   ;;; OFFSET is number of units past a boundry (as determined my M)
  204.  
  205.   (define-integrable (offset-align lc m offset)
  206.     (cond (offset 
  207.            (fx+ offset (as-align (fx- lc offset) m)))
  208.           (else
  209.            (as-align lc m))))
  210.                                                        
  211. ;;; The goal here is to set the address of each IB to the corrected
  212. ;;; value.  Ignoring alignments, this is straigtforward - just add the
  213. ;;; amount from the appropriate slot in the adjustments table.  If
  214. ;;; we do have to deal with alignment,  we compute that amount
  215. ;;; of shrinkage, record it in the alignment sdf, and add the shrinkage
  216. ;;; to the accumulating 'align-error'
  217.  
  218. ;;; [side note: some sdfs are in the vector of sdfs only to indicate that an
  219. ;;;  alignment happens at that point.  When we adjust an ib by reducing the 
  220. ;;;  number of alignment bytes preceeding it, we record the number of
  221. ;;;  bytes eliminated in the alignment sdf width field. ]
  222.  
  223. ;;; The only reason for recording the alignment shrinkage in the alignment
  224. ;;; sdfs, is that we must fix up the mark addresses also.  It is not
  225. ;;; possible to fixup the adjustments table as you go along, because
  226. ;;; you are iterating across the ibs, not the adjustments.
  227. ;;; So instead, we save the shrinks, and them apply them all at once
  228. ;;; to the adjustments vector by calling 'adjust-adjustments-for-alignments.'
  229. ;;; The new adjustments are applied to the marks by calling 'fixup-marks.'
  230.  
  231. (define (fixup-ibs ibv adj's sdfs)
  232.   (let ((ibv-length (vector-length ibv)))
  233.     (iterate loop ((i 0) (align-error 0))  ; accumulated alignment adj's
  234.        (cond ((fx>= i ibv-length) 'done)
  235.              (else
  236.               (let* ((ib (vref ibv i))
  237.                      (sdf# (ib-sdf-number ib))
  238.                      (ib-fix (fx+ align-error (vref adj's sdf#)))
  239.                      (new-ib-addr (fx+ (ib-address ib) ib-fix))
  240.                      (a (ib-align ib)))
  241. ;                (format t "~&ib,sdf#,ib-fix,new-ib-add,error ~s~%" 
  242. ;                    (list ib sdf# ib-fix new-ib-addr align-error))
  243.                 (cond ((not a)
  244.                        (set (ib-address ib) new-ib-addr)
  245.                        (loop (fx+ i 1) align-error))
  246.                       (else
  247.                        (let* ((re-aligned (offset-align (fx- new-ib-addr (car a))
  248.                                                         (cadr a)
  249.                                                         (caddr a)))
  250.                               (shrink (fx- re-aligned new-ib-addr))
  251.                               (align-sdf (vref sdfs (fx- sdf# 1)))
  252.                               )
  253.                          (if (fx> shrink 0) (error "alignment caused increase"))
  254.                          (set (ib-align ib) (fx+ (car a) shrink))
  255.                          (set (ib-address ib) re-aligned)
  256.                          (set (sdf-width align-sdf) shrink)
  257.                          (adjust-align-crossers align-sdf shrink)
  258.                          (loop (fx+ i 1) (fx+ align-error shrink))
  259.                          )))))))))        
  260.  
  261.  
  262. (define (adjust-adjustments-for-alignments adjs sdfs)
  263.   (let ((sdfs-length (vector-length sdfs)))
  264.     (iterate loop ((i 0) (align-error 0))
  265.         ;; because indices info adjs are offset by 1, we can do the
  266.         ;; set here, but it is easier to think about if at the bottom
  267.         (modify (vref adjs i) (lambda (a) (fx+ align-error a)))
  268.         (cond ((fx>= i sdfs-length) 'done)     
  269.               (else
  270.                (let* ((sdf (vref sdfs i))
  271.                       (a (if (empty? (sdf-span sdf)) (sdf-width sdf) 0)))
  272.                  (loop (fx+ i 1) (fx+ align-error a))))))))
  273.  
  274.  
  275.  
  276. (define (fixup-marks m-addrs m-sdf-numbers adjs)
  277.   (if (fxn= (vref adjs 0) 0)
  278.       (error "dummy adjustment slot changed"))
  279.   (let ((len (vector-length m-addrs)))
  280.     (do ((i 0 (fx+ i 1)))             
  281.         ((fx>= i len) 'done)
  282.       (modify (vref m-addrs i) 
  283.               (lambda (ma) 
  284.                 (fx+ ma (vref adjs (vref m-sdf-numbers i))))))))
  285.  
  286.  
  287.